home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Celestin Apprentice 7
/
Apprentice-Release7.iso
/
Source Code
/
Pascal
/
Applications
/
TCPExample
/
PNL Libraries
/
MyConnections.p
< prev
next >
Wrap
Text File
|
1997-06-23
|
21KB
|
889 lines
unit MyConnections;
{ MyConnections © Peter N Lewis, 1993-96 }
interface
uses
Types, TCPTypes, MyTypes, OpenTransport, MyTransport, MyAssertions;
const
tooManyConnections = -23099;
timeoutError = -23098;
failedToOpenError = -23097;
k_max_found_addresses = 10;
{ Sequence: }
{ new(obj) }
{ oe:=obj.Create }
{ if oe=noErr then begin }
{ do stuff}
{ end; }
{ obj.timetodie := true } { Don't call Destroy yourself }
type
ConnectionBaseObject = object
timetodie: boolean; { Set this to have Destroy called at the end of HandleConnection }
connection_index: integer; { private! }
closedone: boolean;
heartbeat_period: longint; { set to <=0 to disable heartbeats }
heartbeat_time: longint; { set to time of next Heartbeat, it is automatically incrememnted by the period }
{ To enable heartbeats, set heartbeat_time to TickCount, and heartbeat_period to the period in ticks }
timeout_time: longint; { set to time to timeout TickCount }
dnr_token: Ptr;
hack_do_test_bad_connections: boolean;
hack_test_bad_connections: boolean;
function Create: OSStatus;
procedure Destroy;
procedure Heartbeat;
procedure Failed (oe: OSStatus);
procedure Close;
procedure HandleConnection;
procedure SetHeartBeat(period: longint);
end;
NameSearchObject = object(ConnectionBaseObject)
ip: longint;
procedure HandleConnection;
override;
procedure FindName (hostIP: longint);
procedure FoundName (name: Str255; error: OSStatus);
end;
AddressSearchObject = object(ConnectionBaseObject)
object_host: Str255;
addresses: array[1..k_max_found_addresses] of ipAddr;
procedure HandleConnection;
override;
procedure FindAddress (hostName: Str255);
procedure FoundAddress (ip: longint);
end;
ListenerObject = object(ConnectionBaseObject)
listener: Ptr;
localport: ipPort;
function Create: OSStatus;
override;
procedure Destroy;
override;
function CreateListener(buffersize:longint; port:ipPort; listeners:integer): OSStatus;
procedure HandleConnection;
override;
procedure ConnectionAvailable( connection: TransportRef ); { override this - do not call it! }
end;
UDPObject = object(ConnectionBaseObject)
tref: TransportUDPRef;
localport: ipPort;
function Create: OSStatus;
override;
function CreatePort (buffersize: longint; port: ipPort): OSStatus;
procedure Close;
override;
procedure Destroy;
override;
procedure HandleConnection;
override;
procedure PacketAvailable (remoteip: ipAddr; remoteport: ipPort; datap: Ptr; datalen: integer);
procedure PacketsAvailable (count: integer);
function SendPacket (remoteip: longint; remoteport: ipPort; datap: Ptr; datalen: integer; checksum: boolean): OSStatus;
end;
statusType = (CS_None, CS_Opening, CS_Established, CS_Closing);
ConnectionObject = object(ConnectionBaseObject)
tref: TransportRef;
status: statusType;
ourport: ipPort;
input_buffer: Handle;
output_buffer: Handle;
transfer_error:OSStatus;
do_send_close: Boolean;
function Create: OSStatus;
override;
procedure Destroy;
override;
procedure HandleConnection;
override;
procedure NewConnection (actve: boolean; buffersize: longint; localport: ipPort; remotehost: Str255);
procedure NewPassiveConnection (buffersize: longint; localport: ipPort);
procedure NewActiveConnection (buffersize: longint; remotehost: Str255);
procedure NewExistingConnection(newtref: TransportRef);
procedure Close;
override;
procedure BeginConnection; { override these }
procedure Established;
procedure Closing;
procedure CharsAvailable;
procedure DoTransfer;
procedure SendString (s: Str255);
procedure SendData(datap: Ptr; len: longint);
end;
LineConnectionObject = object(ConnectionObject)
crlf: CRLFTypes;
last_check: longint; { last input_buffer size, dont recheck unless it changes }
function Create: OSStatus;
override;
procedure CharsAvailable;
override;
procedure SendLine (s: Str255);
procedure LineAvailable (line: Str255);
procedure CheckLineAvailable; { You can override this and use input_buffer yourself }
end;
{$ifc not do_debug}
{$definec AssertValidConnection(c) }
{$elsec}
{$definec AssertValidConnection(c) AssertValidConnectionCode(c)}
{$endc}
{$ifc do_debug}
procedure AssertValidConnectionCode( connection: ConnectionBaseObject );
{$endc}
procedure StartupConnections;
procedure FinishConnections;
function ValidConnection( connection: ConnectionBaseObject ): boolean;
implementation
uses
Devices, TextUtils, Memory, Events,
MyLowLevel,
DNR, MyStrings, MyMemory, MyMathUtils, MyIPStrings, TCPUtils, MyStartup;
{$ifc undefined objects_are_handles}
{$setc objects_are_handles := 1}
{$endc}
const
TCPCMagic = 'TCPC';
TCPCBadMagic = 'badc';
const { Tuning parameters }
connections_max = 128;
TO_FindAddress = 40 * second_in_ticks;
TO_FindName = 40 * second_in_ticks;
TO_ActiveOpen = 20 * second_in_ticks;
TO_Closing = longint(2) * minute_in_ticks;
TO_PassiveOpen = longint(1) * 365 * day_in_ticks; { One years should be safe enough right? :-) }
type
myHostInfo = record
hi: hostInfo;
done: SignedByte;
end;
myHIP = ^myHostInfo;
{$ifc do_debug}
var
startup_check: integer;
{$endc}
var
max_connections: integer;
connections: array[1..connections_max] of ConnectionBaseObject;
quiting: boolean;
function ValidConnection( connection: ConnectionBaseObject ): boolean;
var
i: integer;
begin
ValidConnection := false;
for i := 1 to max_connections do begin
if connections[i] = connection then begin
ValidConnection := true;
leave;
end;
end;
end;
{$ifc do_debug}
procedure AssertValidConnectionCode( connection: ConnectionBaseObject );
begin
Assert( ValidConnection( connection ) );
end;
{$endc}
function ConnectionBaseObject.Create: OSStatus;
var
i: integer;
err: OSStatus;
begin
AssertDidStartup( startup_check );
{$ifc objects_are_handles}
LockHigh(Handle(self));
{$endc}
hack_test_bad_connections := false;
hack_do_test_bad_connections := false;
dnr_token := nil;
err := noErr;
if quiting then begin
err := -12;
end;
if err = noErr then begin
err := OpenTransportSystem;
end;
if err = noErr then begin
i := 1;
while (i <= connections_max) & (connections[i] <> nil) do begin
i := i + 1;
end;
if i <= connections_max then begin
timetodie := false;
connection_index := i;
max_connections := Max( max_connections, i );
connections[i] := self;
heartbeat_period := -1;
heartbeat_time := 0;
timeout_time := maxLongInt;
closedone := false;
end else begin
connection_index := -1;
err := tooManyConnections;
end;
end;
Create := err;
end;
procedure ConnectionBaseObject.Destroy;
begin
if connection_index > 0 then begin
connections[connection_index] := nil;
end;
TransportAbortDNR(dnr_token);
dispose(self);
end;
procedure ConnectionBaseObject.Heartbeat;
begin
end;
procedure ConnectionBaseObject.Failed (err: OSStatus);
begin
{$unused(err)}
timetodie := true;
end;
procedure ConnectionBaseObject.Close;
begin
closedone := true;
end;
procedure ConnectionBaseObject.SetHeartBeat(period: longint);
var
time: longint;
begin
time := TickCount;
if (heartbeat_period <= 0) or (period < 0) then begin
heartbeat_time := time;
end;
heartbeat_period := period;
if heartbeat_time < time then begin
heartbeat_time := time;
end;
if (heartbeat_period > 0) & (heartbeat_time > time + heartbeat_period) then begin
heartbeat_time := time + heartbeat_period;
end;
end;
procedure ConnectionBaseObject.HandleConnection;
var
now: longint;
begin
now := TickCount;
if now > timeout_time then begin
timeout_time := maxLongInt;
Failed(timeoutError);
end else if (heartbeat_period > 0) & (now >= heartbeat_time) then begin
Heartbeat;
heartbeat_time := heartbeat_time + heartbeat_period;
if heartbeat_time < now then begin
heartbeat_time := now;
end;
end;
end;
procedure AddressSearchObject.FindAddress (hostName: Str255);
var
err: OSStatus;
begin
err := Create;
if err = noErr then begin
object_host := hostName;
err := TransportNameToAddr(hostName, dnr_token);
timeout_time := TickCount + TO_FindAddress;
end;
if err <> noErr then begin
Failed(err);
timetodie := true;
end;
end;
procedure AddressSearchObject.FoundAddress (ip: longint);
begin
{$unused(ip)}
end;
procedure AddressSearchObject.HandleConnection;
var
result: OSStatus;
begin
inherited HandleConnection;
if not timetodie then begin
TransportGetNameToAddrResult(dnr_token, result, nil, @addresses, k_max_found_addresses);
if result = noErr then begin
FoundAddress(addresses[1]);
timetodie := true;
end else if result <> inProgress then begin
Failed(result);
timetodie := true;
end;
end;
end;
procedure NameSearchObject.FindName (hostIP: longint);
var
err: OSStatus;
begin
ip := hostIP;
err := Create;
if err = noErr then begin
err := TransportAddrToName(hostIP, dnr_token);
timeout_time := TickCount + TO_FindName;
end;
if err <> noErr then begin
Failed(err);
timetodie := true;
end;
end;
procedure NameSearchObject.FoundName (name: Str255; error: OSStatus);
begin
{$unused(name, error)}
end;
procedure NameSearchObject.HandleConnection;
var
result: OSStatus;
name:Str255;
begin
inherited HandleConnection;
if not timetodie then begin
TransportGetAddrToNameResult(dnr_token, result, name);
if result <> inProgress then begin
if result <> noErr then begin
IPAddrToString( ip, name );
end;
FoundName(name, result);
timetodie := true;
end;
end;
end;
function ListenerObject.Create: OSStatus;
begin
listener := nil;
localport := 0;
Create := inherited Create;
end;
procedure ListenerObject.Destroy;
begin
if listener <> nil then begin
TransportDestroyListener( listener );
end;
inherited Destroy;
end;
function ListenerObject.CreateListener(buffersize:longint; port:ipPort; listeners:integer): OSStatus;
var
err: OSStatus;
begin
err := Create;
if err = noErr then begin
localport := port;
err := TransportListen( listener, localport, listeners, buffersize);
timeout_time := maxLongInt;
end;
if err <> noErr then begin
timetodie := true;
end;
CreateListener := err;
end;
procedure ListenerObject.ConnectionAvailable( connection: TransportRef );
begin
TransportDestroy( connection );
end;
procedure ListenerObject.HandleConnection;
var
connection:TransportRef;
begin
if TransportGetListenerConnection( listener, connection ) = noErr then begin
ConnectionAvailable( connection );
end;
inherited HandleConnection;
end;
function UDPObject.Create: OSStatus;
begin
tref := nil;
localport := 0;
Create := inherited Create;
end;
function UDPObject.CreatePort (buffersize: longint; port: ipPort): OSStatus;
var
err: OSStatus;
begin
err := Create;
if err = noErr then begin
err := TransportUDPOpenPort(tref, port, buffersize);
localport := port;
timeout_time := maxLongInt;
end;
if err <> noErr then begin
timetodie := true;
end;
CreatePort := err;
end;
procedure UDPObject.Close;
begin
timetodie := true;
inherited Close;
end;
procedure UDPObject.Destroy;
begin
TransportUDPDestroy(tref);
inherited Destroy;
end;
procedure UDPObject.PacketAvailable (remoteip: ipAddr; remoteport: ipPort; datap: Ptr; datalen: integer);
begin
{$unused(remoteip, remoteport, datap, datalen)}
end;
procedure UDPObject.PacketsAvailable (count: integer);
var
err: OSStatus;
remoteip: longint;
remoteport: ipPort;
datap: Ptr;
datalen: integer;
begin
{$unused(count)}
err := TransportUDPRead (tref, remoteip, remoteport, datap, datalen);
if err = noErr then begin
PacketAvailable(remoteip, remoteport, datap, datalen);
err := TransportUDPReturnBuffer(tref, datap);
end;
end;
function UDPObject.SendPacket (remoteip: longint; remoteport: ipPort; datap: Ptr; datalen: integer; checksum: boolean): OSStatus;
begin
SendPacket := TransportUDPWrite (tref, remoteip, remoteport, datap, datalen, checksum);
end;
procedure UDPObject.HandleConnection;
var
count: longint;
begin
inherited HandleConnection;
if not timetodie & (tref <> nil) then begin
count := TransportUDPDatagramsAvailable(tref);
if count > 0 then begin
PacketsAvailable(count);
end;
end;
end;
procedure ConnectionObject.Established;
begin
end;
procedure ConnectionObject.Closing;
begin
Close;
end;
procedure ConnectionObject.CharsAvailable;
begin
end;
function ConnectionObject.Create: OSStatus;
var
err, err2:OSStatus;
begin
err := inherited Create;
status := CS_None;
transfer_error := noErr;
do_send_close := false;
err2 := MNewHandle(input_buffer, 0);
if err = noErr then begin
err := err2;
end;
err2 := MNewHandle(output_buffer, 0);
if err = noErr then begin
err := err2;
end;
Create := err;
end;
procedure ConnectionObject.Destroy;
begin
TransportDestroy(tref);
MDisposeHandle(input_buffer);
MDisposeHandle(output_buffer);
inherited Destroy;
end;
procedure ConnectionObject.SendData(datap: Ptr; len: longint);
var
err: OSStatus;
begin
if ((status = CS_Established) or (status = CS_Closing)) and not closedone then begin
err := PtrAndHand(datap, output_buffer, len);
end else begin
err := -24;
end;
if transfer_error = noErr then begin
transfer_error := err;
end;
end;
procedure ConnectionObject.SendString (s: Str255);
begin
SendData(@s[1], length(s));
end;
procedure ConnectionObject.DoTransfer;
procedure SetErr(err:OSStatus);
begin
if (transfer_error = noErr) then begin
transfer_error := err;
end;
end;
var
err: OSStatus;
count, len:longint;
begin
len := MGetHandleSize(input_buffer);
count := Min(TransportCharsAvailable(tref), 10240-len);
if count > 0 then begin
err := MSetHandleSize(input_buffer, len + count);
if err = noErr then begin
HLock(input_buffer);
err := TransportReceive(tref, AddPtrLong(input_buffer^, len), count, count);
HUnlock(input_buffer);
SetErr(err);
SetHandleSize(input_buffer, len + count);
end;
end;
len := MGetHandleSize(output_buffer);
if len > 0 then begin
HLock(output_buffer);
err := TransportSend(tref, output_buffer^, len);
HUnlock(output_buffer);
SetHandleSize(output_buffer, 0);
SetErr(err);
end else if do_send_close then begin
do_send_close := false;
timeout_time := TickCount + TO_Closing;
TransportSendClose(tref);
end;
end;
procedure ConnectionObject.BeginConnection;
begin
end;
procedure ConnectionObject.NewExistingConnection(newtref: TransportRef);
var
err: OSStatus;
begin
err := Create;
tref := newtref;
if err = noErr then begin
err := TransportHandleTransfers(tref);
end;
if err = noErr then begin
status := CS_Established;
ourport := 0;
timeout_time := maxLongInt;
BeginConnection;
Established;
end else begin
Failed(err);
end;
end;
procedure ConnectionObject.NewConnection (active: boolean; buffersize: longint; localport: ipPort; remotehost: Str255);
var
err: OSStatus;
begin
tref := nil;
err := Create;
if err = noErr then begin
status := CS_Opening;
ourport := localport;
if active then begin
err := TransportOpenActiveConnection(tref, remotehost, ourport, buffersize);
timeout_time := TickCount + TO_ActiveOpen;
end else begin
err := TransportOpenPassiveConnection(tref, ourport, buffersize);
timeout_time := TickCount + TO_PassiveOpen;
end;
end;
if err = noErr then begin
err := TransportHandleTransfers(tref);
end;
if err = noErr then begin
BeginConnection;
end else begin
Failed(err);
timetodie := true;
end;
end;
procedure ConnectionObject.NewPassiveConnection (buffersize: longint; localport: ipPort);
begin
NewConnection(false, buffersize, localport, '');
end;
procedure ConnectionObject.NewActiveConnection (buffersize: longint; remotehost: Str255);
begin
NewConnection(true, buffersize, 0, remotehost);
end;
procedure ConnectionObject.Close;
begin
if not closedone and (tref <> nil) then begin
if MGetHandleSize(output_buffer) > 0 then begin
do_send_close := true;
end else begin
timeout_time := TickCount + TO_Closing;
TransportSendClose(tref);
end;
end;
closedone := true;
end;
procedure ConnectionObject.HandleConnection;
var
state: TCPStateType;
result: OSStatus;
begin
inherited HandleConnection;
if not timetodie then begin
case status of
CS_Opening: begin
TransportGetOpenResult(tref, result);
if result = noErr then begin
status := CS_Established;
timeout_time := maxLongInt;
Established;
end else if result <> inProgress then begin
Failed(result);
timetodie := true;
end;
end;
CS_Established: begin
DoTransfer;
state := TransportGetConnectionState(tref);
if hack_test_bad_connections then begin
state := T_Dead;
end;
case state of
T_Established: begin
if MGetHandleSize(input_buffer) > 0 then begin
CharsAvailable;
if hack_do_test_bad_connections & (band( Random(), 31 ) = 1) then begin
hack_test_bad_connections := true;
end;
end;
end;
T_PleaseClose, T_Closing: begin
if MGetHandleSize(input_buffer) > 0 then begin
CharsAvailable;
end else begin
status := CS_Closing;
timeout_time := TickCount + TO_Closing;
Closing;
end;
end;
T_Dead, T_Bored: begin
status := CS_Closing;
timeout_time := TickCount + TO_Closing;
Closing;
end;
otherwise
;
end;
end;
CS_Closing: begin
DoTransfer;
state := TransportGetConnectionState(tref);
if hack_test_bad_connections then begin
state := T_Dead;
end;
case state of
T_PleaseClose, T_Closing, T_Established: begin
if MGetHandleSize(input_buffer) > 0 then begin
CharsAvailable;
end;
end;
T_Dead, T_Bored: begin
timetodie := true;
end;
otherwise
;
end;
end;
otherwise
;
end;
end;
end;
function LineConnectionObject.Create: OSStatus;
begin
crlf := CL_CRLF;
last_check := -1;
Create := inherited Create;
end;
procedure LineConnectionObject.SendLine (s: Str255);
begin
if crlf <> CL_LF then begin
s := concat(s, cr);
end;
if crlf <> CL_CR then begin
s := concat(s, lf);
end;
SendData(@s[1], length(s));
end;
procedure LineConnectionObject.LineAvailable (line: Str255);
begin
{$unused(line)}
end;
procedure LineConnectionObject.CharsAvailable;
begin
CheckLineAvailable;
end;
procedure LineConnectionObject.CheckLineAvailable;
var
len, inbuf: longint;
p: Ptr;
s: Str255;
begin
while true do begin
inbuf := MGetHandleSize(input_buffer);
if (inbuf = 0) | (inbuf = last_check) then begin
leave;
end;
p := input_buffer^;
len := 0;
while (len < inbuf) & (len < 255) & (p^ <> ord(lf)) & (p^ <> ord(cr)) do begin
p := Ptr(ord(p) + 1);
len := len + 1;
end;
if (len = 255) | ((len < inbuf) & ((p^ = ord(lf)) | (p^ = ord(cr)))) then begin
{$PUSH}
{$R-}
s[0] := chr(len);
BlockMoveData(input_buffer^, @s[1], len);
{$POP}
if (len < inbuf) & (p^ = ord(cr)) then begin
p := Ptr(ord(p) + 1);
len := len + 1;
end;
if (len < inbuf) & (p^ = ord(lf)) then begin
p := Ptr(ord(p) + 1);
len := len + 1;
end;
MMungerDelete(input_buffer, 0, len);
LineAvailable(s);
last_check := -1;
end else begin
last_check := inbuf;
end;
end;
end;
procedure IdleConnections;
var
i: integer;
begin
for i := 1 to max_connections do begin
if connections[i] <> nil then begin
if not connections[i].timetodie then begin
connections[i].HandleConnection;
end;
if connections[i].timetodie then begin
connections[i].Destroy;
end;
end;
end;
end;
procedure DestroyAll( fail: Boolean );
var
i: integer;
begin
for i := 1 to max_connections do begin
if connections[i] <> nil then begin
if fail then begin
connections[i].Failed( kOTClientNotInittedErr );
end;
connections[i].Destroy;
end;
end;
max_connections := 0;
end;
procedure FinishConnections;
begin
quiting := true;
DestroyAll( false );
end;
procedure TransitionNotifier( up: boolean );
begin
if not up then begin
DestroyAll( true );
end;
end;
function InitConnections( var msg: integer ): OSStatus;
var
i: integer;
begin
{$unused(msg)}
DidStartup( startup_check );
TransportInstallTransitionNotifier( TransitionNotifier );
quiting := false;
for i := 1 to connections_max do begin
connections[i] := nil;
end;
max_connections := 0;
InitConnections := noErr;
end;
procedure StartupConnections;
begin
StartupTransport;
SetStartup(InitConnections, IdleConnections, 0, FinishConnections);
end;
end.